home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
gametp20.zip
/
MISCFUNC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-11-06
|
7KB
|
320 lines
Unit MiscFunc;
{ MiscFunc version 1.0 Scott D. Ramsay }
{ This is my misc. function unit. Some of the functions have }
{ nothing to do with games design but, my units use it so ... }
{ MiscFunc.pas is free. Go crazy. }
{ I've been writing comments to these units all night. Since you }
{ have the source to this, I'll let you figure out what each one }
{ does. }
Interface
function strint(s:string):longint;
function intstr(l:longint):string;
function ups(s:string):string;
function st(h:longint):string;
function compare(s1,s2:string):boolean;
function dtcmp(var s1,s2;size:word):boolean;
function lz(i,w:longint):string;
function vl(h:string):longint;
function spaces(h:integer):string;
function repstr(h:integer;ch:char):string;
function anything(s:string):boolean;
function exist(f:string):boolean;
function errmsg(n:integer):string;
function turboerror(errorcode:integer) : string;
procedure funpad(var s:string);
procedure unpad(var s:string);
procedure munpad(var s:string;b:byte);
function fpad(s:string;h:integer):string;
procedure pad(var s:string;h:integer);
procedure fix(var s:string;h:string);
procedure fixh(var s:string);
function range(x,y,x1,y1,x2,y2:integer) : boolean;
function between(x,x1,x2:integer):boolean;
Implementation
function range(x,y,x1,y1,x2,y2:integer) : boolean;
{ returns true if (x,y) is in the rectangular region (x1,y1,x2,y2) }
begin
range := ((x>=x1) and (x<=x2) and (y>=y1) and (y<=y2));
end;
procedure fix(var s:string;h:string);
begin
if pos('.',s)=0
then s := s+h;
end;
procedure fixh(var s:string);
var
d : integer;
begin
for d := 1 to length(s) do
if s[d]<#32
then s[d] := ' ';
for d := length(s)+1 to 255 do
s[d] := ' ';
end;
function strint(s:string):longint;
var
l : longint;
begin
move(s[1],l,sizeof(l));
strint := l;
end;
function intstr(l:longint):string;
var
s : string;
begin
move(l,s[1],sizeof(l));
s[0] := #4;
intstr := s;
end;
function ups(s:string):string;
var
d : integer;
begin
for d := 1 to length(s) do
s[d] := upcase(s[d]);
ups := s;
end;
function st(h:longint):string;
var
s : string;
begin
str(h,s);
st := s;
end;
function compare(s1,s2:string):boolean;
var
d : byte;
e : boolean;
begin
e := true;
for d := 1 to length(s1) do
if upcase(s1[d])<>upcase(s2[d])
then e := false;
compare := e;
end;
function dtcmp(var s1,s2;size:word):boolean;
var
d : word;
e : boolean;
begin
e := true;
d := size;
while (d>0) and e do
begin
dec(d);
e := (mem[seg(s1):ofs(s1)+d]=mem[seg(s2):ofs(s2)+d]);
end;
dtcmp := e;
end;
function lz(i,w:longint):string;
var
d : longint;
s : string;
begin
str(i,s);
for d := length(s) to w-1 do
s := concat('0',s);
lz := s;
end;
function vl(h:string):longint;
var
d : longint;
e : integer;
begin
val(h,d,e);
vl := d;
end;
function spaces(h:integer):string;
var
s : string;
begin
s := '';
while h>0 do
begin
dec(h);
s := concat(s,' ');
end;
spaces := s;
end;
function repstr(h:integer;ch:char):string;
var
s : string;
begin
s := '';
while h>0 do
begin
dec(h);
s := s+ch;
end;
repstr := s;
end;
function anything(s:string):boolean;
var
d : integer;
h : boolean;
begin
if length(s)=0
then
begin
anything := false;
exit;
end;
h := false;
for d := 1 to length(s) do
if s[d]>#32
then h := true;
anything := h;
end;
function exist(f:string):boolean;
var
fil : file;
begin
if f=''
then
begin
exist := false;
exit;
end;
assign(fil,f);
{$i- }
reset(fil);
close(fil);
{$i+ }
exist := (ioresult=0);
end;
function errmsg(n:integer):string;
begin
case n of
-1 : errmsg := '';
-2 : errmsg := 'Error reading data file';
-3 : errmsg := '';
-4 : errmsg := 'equal current data file name';
150 : errmsg := 'Disk is write protected';
152 : errmsg := 'Drive is not ready';
156 : errmsg := 'Disk seek error';
158 : errmsg := 'Sector not found';
159 : errmsg := 'Out of Paper';
160 : errmsg := 'Error writing to printer';
1000 : errmsg := 'Record too large';
1001 : errmsg := 'Record too small';
1002 : errmsg := 'Key too large';
1003 : errmsg := 'Record size mismatch';
1004 : errmsg := 'Key size mismatch';
1005 : errmsg := 'Memory overflow';
else errmsg := 'Error result #'+st(n);
end;
end;
function turboerror(errorcode:integer) : string;
begin
case errorcode of
1: turboerror := 'Invalid DOS function code';
2: turboerror := 'File not found';
3: turboerror := 'Path not found';
4: turboerror := 'Too many open files';
5: turboerror := 'File access denied';
6: turboerror := 'Invalid file handle';
8: turboerror := 'Not enough memory';
12: turboerror := 'Invalid file access code';
15: turboerror := 'Invalid drive number';
16: turboerror := 'Cannot remove current directory';
17: turboerror := 'Cannot rename across drives';
100: turboerror := 'Disk read error';
101: turboerror := 'Disk write error';
102: turboerror := 'File not assigned';
103: turboerror := 'File not open';
104: turboerror := 'File not open for input';
105: turboerror := 'File not open for output';
106: turboerror := 'Invalid numeric format';
200: turboerror := 'Division by zero';
201: turboerror := 'Range check error';
202: turboerror := 'Stack overflow error';
203: turboerror := 'Heap overflow error';
204: turboerror := 'Invalid pointer operation';
else turboerror := errmsg(errorcode);
end;
end;
procedure funpad(var s:string);
begin
while s[1]=' ' do
delete(s,1,1);
end;
procedure unpad(var s:string);
begin
while (length(s)>0) and (s[length(s)]<=' ') do
delete(s,length(s),1);
end;
procedure munpad(var s:string;b:byte);
begin
s[0] := char(b);
while (length(s)>0) and (s[length(s)]<=' ') do
delete(s,length(s),1);
end;
function fpad(s:string;h:integer):string;
begin
while length(s)<h do
s := concat(s,' ');
fpad := s;
end;
procedure pad(var s:string;h:integer);
begin
while length(s)<h do
s := concat(s,' ');
end;
function between(x,x1,x2:integer):boolean;
begin
between := ((x>=x1) and (x<=x2));
end;
end.